home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 5 Developer's Kit / vb5 dev kit.iso / dev / ftp4w26a / samples / pascal / pwftp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-10  |  9.7 KB  |  341 lines
  1. Program PWFTP;
  2. {$A+,B-,D+,F-,G+,I-,K+,L+,N-,P+,Q+,R+,S+,T+,V+,W+,X+,Y+}
  3.  
  4. Uses WinTypes, WinProcs, WinCrt, Strings, UseFTP4W;
  5.  
  6. Const TIL = 255;
  7.  
  8. Type PTextItem = ^TTextItem;
  9.      TTextItem = Array [0..TIL] Of Char;
  10.      PLongTextItem = ^TLongTextItem;
  11.      TLongTextItem = Array [0..$FF00] Of Char;
  12.  
  13.      PWndProc = ^TWndProc;
  14.      TWndProc = Function (Receiver: hWnd; MSG, wParam: Word; lParam: LongInt): LongInt;
  15.  
  16. Var Status, TransferMode: Integer;
  17.     T, U: TTextItem;
  18.     TerminateProgram, Flag: Boolean;
  19.     hWindow: hWnd;
  20.     SaveWndProc: TWndProc;
  21.     Data: PFtp_ProcData;
  22.  
  23. Procedure WriteWinsockVerInfo;
  24.   Const WSADESCRIPTION_LEN = 256;
  25.         WSASYS_STATUS_LEN = 128;
  26.   Type TWSAData = Record
  27.            wVersion: Word;
  28.            wHighVersion: Word;
  29.            szDescription: Array [0..WSADESCRIPTION_LEN] Of Char;
  30.            szSystemStatus: Array [0..WSASYS_STATUS_LEN] Of Char;
  31.            iMaxSockets: Byte;
  32.            iMaxUdpDg: Byte;
  33.            lpVendorInfo: Pointer;
  34.          End;
  35.        TWSAStartUp = Function (wVersionRequested: Word; WSAData: TWSAData): Integer;
  36.        TWSACleanup = Function: Integer;
  37.   Var WSAData: TWSAData;
  38.       hWinsock: THandle;
  39.       FP : TFarProc;
  40.   Begin
  41.     hWinsock := LoadLibrary ('WINSOCK');
  42.     If hWinsock >= 32 Then
  43.       Begin
  44.         FP := GetProcAddress (hWinsock, 'WSAStartup');
  45.         If FP <> NIL Then
  46.           If TWSAStartUp (FP) (257, WSAData) = 0 Then
  47.             WriteLn (WSAData.szDescription);
  48.         FP := GetProcAddress (hWinsock, 'WSACleanup');
  49.         If FP <> NIL Then TWSACleanUp (FP);
  50.         FreeLibrary (hWinsock)
  51.       End
  52.   End;
  53.  
  54. Function MyWndProc (Receiver: hWnd; MSG, wParam: Word; lParam: LongInt): LongInt; Export;
  55.   Var W, L: Word;
  56.   Begin
  57.     If MSG = wm_User+10 Then {verbose}
  58.       Begin
  59.         If WhereX <> 1 Then
  60.           Begin
  61.             WriteLn;
  62.             Write (#8);  {delete last "*" after get}
  63.           End;
  64.         L := StrLen (PLongTextItem (lParam)^);
  65.         For W := 0 To L Do
  66.           If PLongTextItem (lParam)^ [W] <> #13 Then
  67.             If PLongTextItem (lParam)^ [W] = #10 Then WriteLn
  68.               Else Write (PLongTextItem (lParam)^ [W]);
  69.         If L > 0 Then
  70.           If PLongTextItem (lParam)^ [L-1] <> #10 Then WriteLn;
  71.       End;
  72.     If MSG = wm_User+11 Then {dir, ls}
  73.       Begin
  74.         If wParam = 1 Then
  75.           Begin
  76.             Status := lParam;
  77.             Flag := True
  78.            End
  79.            Else WriteLn (PChar (lParam));
  80.       End;
  81.     If MSG = wm_User+12 Then {get, put}
  82.       Begin
  83.         If wParam = 1 Then
  84.           Begin
  85.             Status := lParam;
  86.             Flag := True
  87.            End
  88.           Else Write ('*');
  89.       End;
  90.     If MSG = wm_Char Then
  91.       Begin
  92.         If wParam = vk_Escape Then
  93.           Begin
  94.             FtpAbort;
  95.             Status := FtpFlush;
  96.           End;
  97.         If wParam = vk_Cancel Then
  98.           Begin
  99.             FtpAbort;
  100.             WriteLn (#13#10'### Disconnecting ###');
  101.             Halt;
  102.           End;
  103.       End;
  104.     MyWndProc := SaveWndProc (Receiver, MSG, wParam, lParam);
  105.   End;
  106.  
  107. Procedure WriteHostType;
  108.   Type TPA = Array [0..3] Of PChar;
  109.   Var PA: TPA;
  110.   Begin
  111.     PA [0] := StrNew ('Unix');
  112.     PA [1] := StrNew ('VMS');
  113.     PA [2] := StrNew ('Dos');
  114.     PA [3] := NIL;
  115.     Status := FtpSyst (@PA);
  116.     If Status < 1000 Then WriteLn ('Detected host type: ', PA [Status]);
  117.     StrDispose (PA[0]);
  118.     StrDispose (PA[1]);
  119.     StrDispose (PA[2]);
  120.   End;
  121.  
  122. Procedure AnalyseLine (Var Line, Command, Params: String);
  123.   Var I: Byte;
  124.   Begin
  125.     I := Pos (' ', Line);
  126.     If I = 0 Then
  127.       Begin
  128.         Command := Line;
  129.         Params := '';
  130.         Exit
  131.       End;
  132.     Command := Copy (Line, 1, I-1);
  133.     Params := Copy (Line, I+1, TIL);
  134.   End;
  135.  
  136. Procedure DoOpen (Var Line: String);
  137.   Var S, H: String;
  138.   Begin
  139.     AnalyseLine (Line, H, S);
  140.     If Length (H) = 0 Then
  141.       Begin
  142.         Write ('to: ');
  143.         ReadLn (H);
  144.         If Length (H) = 0 Then Exit;
  145.       End;
  146.   StrPCopy (T, H);
  147.   Status := FTPOpenConnection (T);
  148.   If Status <> FTPERR_OK Then Exit;
  149.   AnalyseLine (S, H, S);
  150.   If Length (H) = 0 Then
  151.     Begin
  152.       Write ('user: ');
  153.       ReadLn (H);
  154.     End;
  155.   StrPCopy (T, H);
  156.   Status := FTPSendUserName (T);
  157.   If (Status <> FTPERR_OK) And (Status <> FTPERR_ENTERPASSWORD) Then Exit;
  158.   If Length (S) = 0 Then
  159.     Begin
  160.       Write ('password: ');
  161.       ReadLn (S);
  162.     End;
  163.   StrPCopy (T, S);
  164.   Status := FTPSendPasswd (T);
  165.   If Status <> FTPERR_OK Then Exit;
  166.   WriteLn ('Connected to ', Data^.Ftp.saSockAddr.in_addr.B1,
  167.     '.', Data^.Ftp.saSockAddr.in_addr.B2,
  168.     '.', Data^.Ftp.saSockAddr.in_addr.B3,
  169.     '.', Data^.Ftp.saSockAddr.in_addr.B4);
  170.   WriteHostType;
  171. End;
  172.  
  173. Procedure DoDir (Var Line: String);
  174.   Var I: Integer;
  175.   Begin
  176.     Flag := False;
  177.     StrPCopy (T, Line);
  178.     Status := FtpDir (T, NIL, TRUE, hWindow, wm_User+11);
  179.     If Status <> FTPERR_OK Then Exit;
  180.     Repeat Write (#0) Until Flag;
  181.   End;
  182.  
  183. Procedure DoMode (Var Line: String);
  184.   Begin
  185.     If Length (Line) > 0 Then
  186.       Case Upcase (Line [1]) Of
  187.           'B' : TransferMode := TYPE_I;
  188.           'A' : TransferMode := TYPE_A
  189.         Else WriteLn ('?unknown mode');
  190.         End;
  191.     Case TransferMode Of
  192.         TYPE_I : WriteLn ('mode is binary');
  193.         TYPE_A : WriteLn ('mode is ascii');
  194.       End;
  195.      Status := FTPERR_OK;
  196.   End;
  197.  
  198. Procedure DoGet (Var Line: String);
  199.   Var H: String;
  200.   Begin
  201.     Flag := False;
  202.     AnalyseLine (Line, H, Line);
  203.     StrPCopy (T, H);
  204.     If Length (Line) = 0 Then StrCopy (U, T) Else StrPCopy (U, Line);
  205.     Status := FtpRecvFile (T, U, TransferMode, TRUE, hWindow, wm_User+12);
  206.     If Status = FTPERR_OK Then Repeat Write (#0) Until Flag;
  207.     Write (#8);
  208.   End;
  209.  
  210. Procedure DoPut (Var Line: String);
  211.   Var H: String;
  212.   Begin
  213.     Flag := False;
  214.     AnalyseLine (Line, H, Line);
  215.     StrPCopy (T, H);
  216.     If Length (Line) = 0 Then StrCopy (U, T) Else StrPCopy (U, Line);
  217.     Status := FtpSendFile (T, U, TransferMode, TRUE, hWindow, wm_User+12);
  218.     If Status = FTPERR_Ok Then Repeat Write (#0) Until Flag;
  219.   End;
  220.  
  221. Procedure DoQuote (Var WholeLine: String);
  222.   Begin
  223.     StrPCopy (T, WholeLine);
  224.     Status := FtpQuote (T, NIL, 0);
  225.     If Status < 1000 Then Status := FTPERR_OK;
  226.   End;
  227.  
  228. Procedure DoCD (Var Line: String);
  229.   Begin
  230.     StrPCopy (T, Line);
  231.     If Line = '..' Then Status := FtpCDUP
  232.       Else If Line <> '' Then Status := FtpCWD (T);
  233.     If Status < 1000 Then Status := FtpPWD (NIL, 0)
  234.       Else WriteLn (Status);
  235.   End;
  236.  
  237. Procedure DoCDPP (Var Line: String);
  238.   Begin
  239.     Status := FtpCDUP;
  240.     If Status < 1000 Then Status := FtpPWD (NIL, 0)
  241.   End;
  242.  
  243. Procedure DoHelp (Var Line: String);
  244.   Begin
  245.     StrPCopy (T, Line);
  246.     If Length (Line) > 0 Then Status := FtpHelp (T, NIL, 0)
  247.       Else Status := FtpQuote ('help', NIL, 0);
  248.   End;
  249.  
  250. Procedure DoLocalHelp (Var Line: String);
  251.   Begin
  252.     WriteLn ('open [host] [user] [password]   open connection to host');
  253.     WriteLn ('dir [selection]                 print directory');
  254.     WriteLn ('cd [new dir or ..]              change directory');
  255.     WriteLn ('mode [binary|ascii]             change transfermode');
  256.     WriteLn ('get remotefile [localfile]      download file');
  257.     WriteLn ('put localfile [remotefile]      upload file');
  258.     WriteLn ('remotehelp [command]            get help from host');
  259.     WriteLn ('info                            print info about connections');
  260.     WriteLn ('close                           close connection');
  261.     WriteLn ('bye                             quit FTP client');
  262.     WriteLn ('--> arguments in brackets are optional <--');
  263.     WriteLn ('ESCAPE                          cancel transfer');
  264.     WriteLn ('CONTROL-C                       abort program');
  265.     Status := FTPERR_Ok;
  266.   End;
  267.  
  268. Procedure DoInfo (Var Line: String);
  269.   Var P: PFtp_ProcData;
  270.       B: Byte;
  271.   Begin
  272.     P := Data;
  273.     While P^.Prev <> NIL Do P := P^.Prev;
  274.     B := 0;
  275.     While P <> NIL Do
  276.       Begin
  277.         Inc (B);
  278.         P := P^.Next
  279.       End;
  280.     WriteLn ('Number of tasks: ', B);
  281.     Status := FTPERR_OK;
  282.   End;
  283.  
  284. Procedure DoClose (Var Line: String);
  285.   Begin
  286.     Status := FTPCloseConnection;
  287.   End;
  288.  
  289. Procedure MainLoop;
  290.   Var Line, S, H: String;
  291.   Begin
  292.     TerminateProgram := False;
  293.     Repeat
  294.       Status := -10;
  295.       Write ('ftp>');
  296.       ReadLn (Line);
  297.       AnalyseLine (Line, H, S);
  298.       If H = '' Then Status := FTPERR_OK;
  299.       If H = 'open' Then DoOpen (S);
  300.       If H = 'close' Then DoClose (S);
  301.       If (H = 'dir') Or (H = 'ls') Then DoDir (S);
  302.       If H = 'mode' Then DoMode (S);
  303.       If H = 'get' Then DoGet (S);
  304.       If H = 'put' Then DoPut (S);
  305.       If Line = 'cd..' Then DoCDPP (S);
  306.       If H = 'cd' Then DoCD (S);
  307.       If H = 'remotehelp' Then DoHelp (S);
  308.       If (H = '?') or (H = 'help') Then DoLocalHelp (S);
  309.       If H = 'info' Then DoInfo (S);
  310.       If H = 'bye' Then
  311.         Begin
  312.           DoClose (S);
  313.           Status := FTPERR_OK;
  314.           TerminateProgram := True;
  315.         End;
  316.       If Status = -10 Then DoQuote (Line);
  317.       If Status >= 1000 Then WriteLn ('?', FTP4W_Error (Status));
  318.     Until TerminateProgram;
  319.   End;
  320.  
  321. Var FP: TFarProc;
  322.  
  323. Begin
  324.   CheckBreak := False;
  325.   CmdShow := sw_showMaximized;
  326.   WriteLn ('Simple FTP Client V1.1  by AStA (Andreas.Tikart@uni-konstanz.de) <Polarwolf>');
  327.   Ftp4wVer (T, TIL);
  328.   WriteLn (T);
  329.   WriteWinsockVerInfo;
  330.   hWindow := GetFocus;
  331.   LongInt (FP) := SetWindowLong (hWindow, GWL_WndProc, LongInt (@MyWndProc));
  332.   SaveWndProc := TWndProc (FP);
  333.   Status := FTPInit (hWindow);
  334.   Data := FtpDataPtr;
  335.   FtpSetVerboseMode (Integer (TRUE), hWindow, wm_User+10);
  336.   TransferMode := Type_I;
  337.   MainLoop;
  338.   FtpRelease;
  339.   DoneWinCrt;
  340. End.
  341.